home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / ProcTool.bas < prev    next >
BASIC Source File  |  1997-06-14  |  5KB  |  143 lines
  1. Attribute VB_Name = "MProcTool"
  2. Option Explicit
  3.  
  4. Public Enum EErrorProcTool
  5.     eeBaseProcTool = 13570  ' ProcTool
  6. End Enum
  7.  
  8. Function TopWndFromProcID(idProcA As Long) As Long
  9.     Dim idProc As Long, hWnd As Long
  10.     
  11.     ' Get first window
  12.     hWnd = GetWindow(GetDesktopWindow(), GW_CHILD)
  13.     Do While hWnd <> hNull
  14.         ' Check instance until it matches
  15.         Dim sTitle As String
  16.         sTitle = MWinTool.WindowTextLineFromWnd(hWnd)
  17.         idProc = MWinTool.ProcIDFromWnd(hWnd)
  18.         If idProcA = idProc Then
  19.             If MWinTool.IsVisibleTopWnd(hWnd) Then Exit Do
  20.         End If
  21.  
  22.         ' Get next sibling
  23.         hWnd = GetWindow(hWnd, GW_HWNDNEXT)
  24.     Loop
  25.     TopWndFromProcID = hWnd
  26. End Function
  27.     
  28. Public Function GetProcInfo(ByVal ID As Long, Optional TabStop As Integer = 0) As String
  29.     Dim sStart As String, s As String, sTemp As String
  30.     
  31.     ' Nested starting position
  32.     sStart = Space$(TabStop * 4)
  33.     ' Module information
  34.     s = sStart & "Program: " & MModTool.ExeNameFromProcID(ID) & sCrLf
  35.     s = s & sStart & "Module: " & Hex$(MModTool.ModFromProcID(ID)) & sCrLf
  36.     s = s & sStart & "Instance: " & Hex$(MModTool.InstFromProcID(ID)) & sCrLf
  37.     s = s & sStart & "PID: " & ID & sCrLf
  38.  
  39.     GetProcInfo = s
  40. End Function
  41.  
  42. ' Pass idProg returned by Shell or ShellPlus
  43. Function IsRunning(ByVal idProg As Long, _
  44.                    Optional ExitCode As Long) As Boolean
  45.     Static hProg As Long
  46.     ' Get process handle first time through and save it
  47.     If hProg = hNull Then
  48.         hProg = OpenProcess(PROCESS_QUERY_INFORMATION, False, idProg)
  49.     End If
  50.     If hProg = hNull Then
  51.         ' Invalid idProc because program completed before first call
  52.         ExitCode = 0
  53.     Else
  54.         ' Got a valid handle so use it to check process status
  55.         GetExitCodeProcess hProg, ExitCode
  56.     End If
  57.     If ExitCode = STILL_ACTIVE Then
  58.         IsRunning = True
  59.     Else
  60.         CloseHandle hProg
  61.     End If
  62. End Function
  63.  
  64. Function WaitOnProgram(ByVal idProg As Long, _
  65.                        Optional ByVal WaitDead As Boolean) As Long
  66.     Dim cRead As Long, iExit As Long, hProg As Long
  67.     ' Get process handle
  68.     hProg = OpenProcess(PROCESS_ALL_ACCESS, False, idProg)
  69.     If WaitDead Then
  70.         ' Stop dead until process terminates
  71.         Dim iResult As Long
  72.         iResult = WaitForSingleObject(hProg, INFINITE)
  73.         If iResult = WAIT_FAILED Then ErrRaise Err.LastDllError
  74.         ' Get the return value
  75.         GetExitCodeProcess hProg, iExit
  76.     Else
  77.         ' Get the return value
  78.         GetExitCodeProcess hProg, iExit
  79.         ' Wait, but allow painting and other processing
  80.         Do While iExit = STILL_ACTIVE
  81.             DoEvents
  82.             GetExitCodeProcess hProg, iExit
  83.         Loop
  84.     End If
  85.     CloseHandle hProg
  86.     WaitOnProgram = iExit
  87. End Function
  88.  
  89. ' Combine foreground and background console color attributes
  90. Function ColorAttr(ByVal atrFore As Byte, ByVal atrBack As Byte) As Long
  91.     ColorAttr = MBytes.LShiftWord((&HF And atrBack), 4) Or (&HF And atrFore)
  92. End Function
  93.  
  94. Function VBShellExecute(sFile As String, _
  95.                         Optional Args As String, _
  96.                         Optional Show As Long = vbNormalFocus, _
  97.                         Optional InitDir As String, _
  98.                         Optional Verb As String, _
  99.                         Optional hWnd As Long = hNull) As Long
  100.     Dim ID As Long
  101.     ID = ShellExecute(hWnd, Verb, sFile, Args, InitDir, Show)
  102.     ' Translate weird ShellExecute errors into normal errors
  103.     Select Case ID
  104.     Case 0
  105.         ID = ERROR_NOT_ENOUGH_MEMORY
  106.     Case SE_ERR_SHARE                                       ' 26
  107.         ID = ERROR_SHARING_VIOLATION
  108.     Case SE_ERR_ASSOCINCOMPLETE                             ' 27
  109.         ID = ERROR_NO_ASSOCIATION
  110.     Case SE_ERR_DDETIMEOUT, SE_ERR_DDEFAIL, SE_ERR_DDEBUSY  ' 28, 29, 30
  111.         ID = ERROR_DDE_FAIL
  112.     Case SE_ERR_NOASSOC                                     ' 31
  113.         ID = ERROR_NO_ASSOCIATION
  114.     Case SE_ERR_DLLNOTFOUND                                 ' 32
  115.         ID = ERROR_DLL_NOT_FOUND
  116.     Case Is > 32
  117.         VBShellExecute = ID
  118.         Exit Function
  119.     End Select
  120.     ApiRaise ID
  121. End Function
  122.  
  123. #If fComponent = 0 Then
  124. Private Sub ErrRaise(e As Long)
  125.     Dim sText As String, sSource As String
  126.     If e > 1000 Then
  127.         sSource = App.ExeName & ".ProcTool"
  128.         Select Case e
  129.         Case eeBaseProcTool
  130.             BugAssert True
  131.        ' Case ee...
  132.        '     Add additional errors
  133.         End Select
  134.         Err.Raise COMError(e), sSource, sText
  135.     Else
  136.         ' Raise standard Visual Basic error
  137.         sSource = App.ExeName & ".VBError"
  138.         Err.Raise e, sSource
  139.     End If
  140. End Sub
  141. #End If
  142.  
  143.